00100	C******** TRONLY, ZSIG, AVERG *********************************
00200	
00300		SUBROUTINE TRONLY
00500		COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1) /PTR/JST(1)
00600	 	1 /RCLF/KK,CLEF,KW,KTEM,RSTAFF,SN,YN,RNAM,IRV,ITR
00700		1 /IPG/IPG,JPG,XCLEF,RSTNUM(8),RPSZ(8),RHGT(8),RRCLEF(8)
00800		1 /ITX/ITX(18)
00900		1 /TRAN/RTR(17),KTR(17)
00910		EQUIVALENCE (ITEM,JST(18)),(ITOT,JST(19))
01000	1000	FORMAT(' TYPE INPUT NAME.EXT   ',$)
01100	2200	FORMAT(A5,A1,A3)
01200	2201	FORMAT(1XA5,'.',A3)
01300	400	FORMAT(' OUTPUT NAME.EXT   ',$)
01400	6	FORMAT(' WRITE OVER ',A5,'.',A3,'?  ',$)
01500	8	FORMAT(A1)
01600	304	FORMAT(' TRANSP.= '$)
01700	306	FORMAT(I)
01800		IDONE=0
01900		SIG=-99
02000		XSIG=0
02100	300	TYPE 1000
02200		ACCEPT 2200,NM,XIN,XIN
02300		IF(XIN.EQ.' ')XIN='MS'
02400		NX=NM+256
02500	2001	TYPE 304
02600		ACCEPT 2101,ITR
02700		IF(ITR.GT.-20)GO TO 1101
02800	2101	FORMAT(A3)
02900	C  NEXT FOR LETTER NAMES 
03000		DO 3101 K=1,18
03100	3101	IF(ITR.EQ.ITX(K))GO TO 4101
03200	5101	TYPE 240
03300		GO TO 2001
03400	240	FORMAT(' THIS TRANSP NOT OFFERED')
03500	1101	REREAD 306,ITR
03600		IF(ITR.EQ.0)GO TO 300
03700		ITR=10-ITR
03800		IF(ITR.EQ.22)ITR=17
03900	C FOR DOWN OCT.
04000		IF(ITR.GT.0)GO TO 700
04100		IF(ITR.EQ.-2)ITR=18
04200	C  -2 NOW = UP OCT.
04300		GO TO 700
04400	4101	ITR=K
04500		
04600	700	TYPE 400
04700		ACCEPT 2200,NOUT,K,XOUT
04800		IF(NOUT.NE.' ')GO TO 5
04900		NOUT='AAAAA'
05000		XOUT='TST'
05100	C DEFAULT NAMES
05200	5	IF(XOUT.EQ.' ')XOUT='TST'
05300		IF(LOOKX(NOUT,XOUT).GE.0)GO TO 11
05400		TYPE 6,NOUT,XOUT
05500		ACCEPT 8,K
05600		IF(K.EQ.'N')GO TO 700
05700	11	JOUT=NOUT+256
05800	10	IF(LOOKX(NM,XIN).LT.0)GO TO 9
05900		NM=NX
06000		NX=NX+256
06100	C  WILL READ UP TO 52 FILES.
06200		NOUT=JOUT
06300		JOUT=JOUT+256
06400		IF(LOOKX(NM,XIN).LT.0)GO TO 9
06500		IF(IDONE.EQ.0)TYPE 290
06600		CALL EXIT
06700	290	FORMAT(
06800		1' **** FILE NOT FOUND.  NAMES MUST HAVE 5 LETTERS.****')
06900	9	IDONE=-1
07000		CALL GETEXT(NM,XIN)
07100		CALL EXTIN(JST,128)
07200		CALL EXTIN(KPN,ITEM)
07300		CALL EXTIN(Q,ITOT)
07400		TYPE 2201,NM,XIN
07500		ITEM=ITEM-2
07600	
07700	C  NEXT SORTS INTO LEFT-TO-RIGHT
07800		KL=1
07900		JPG=ITEM-1
08000	333	DO 33 K=KL,JPG 
08100		IF(CODEN(KPN,K,Q,J).GT.6)GO TO 33
08200		A=Q(J+3)
08300		DO 3333 J=K+1,JPG
08400		IF(CODEN(KPN,J,Q,L).GT.6)GO TO 3333
08500		IF(A.LE.Q(L+3))GO TO 3333
08600		CALL EXCH(KPN(J),KPN(K))
08700	CC	KL=J-1
08800		GO TO 333
08900	3333	CONTINUE
09000		KL=K+1
09100	33	CONTINUE
09200	
09300	C NEXT FIND HOW MANY STAVES.  KSIG?
09400		RS=0
09500		DO 32 K=1,ITEM
09600		R=CODEN(KPN,K,Q,J)
09700		IF(R.GT.2)GO TO 32
09800		IF(Q(J+2).GT.RS)RS=Q(J+2)
09900	32	IF(R.EQ.17)SIG=0
10000		JPG=RS+1
10100		JITEM=ITEM
10200	
10300		IOCT=0
10400		KW=0
10500		IF(ITR.LE.17)GO TO 1002
10600		RT=7
10700	C OCTAVE ↑ = 19,  - = 18
10800		IF(ITR.EQ.18)RT=-RT  
10900		IOCT=-1
11000		GO TO 199
11100	C  FOUND KSIG, SO DON'T DO THE REST
11200	1002	IF(XSIG.NE.0)GO TO 199 
11300		RT=0
11400		IF(ITR.EQ.0)RETURN
11500		RT=RTR(ITR)
11600	C  EEb,EE,F-,F#-,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F,G↑  BBb, 8-, 8↑
11700	41	NSIG=-1
11800		IF(SIG.EQ.0)GO TO 699
11900	C  ASSUMES KSIG DESIRED IF ONE THERE ALREADY.
12000		RSIG=-1
12100		IF(ZSIG(XSIG).NE.'Y')GO TO 199
12200	C FUNCTION ZSIG ASKS 'ADD KEY SIG?'
12300	699	NSIG=0
12400		RSIG=0
12500		XSIG=99
12600	
12700	C  ***** NEXT FOR KEY SIG. ********
12800		IADD=KTR(ITR)
12900	C  ADD= ADD OR SUBTR. # OR b  FROM KSIG.
13000	C  EEb,EE,F-,F#-,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F,G  BBb, 8-, 8↑
13100	199	K=1
13200		XCLEF=0
13300		CLEF=-1
13400	CC	RSIG=0
13500		SLUR=0
13600		PRX=99
13700		MS=1
13800		SN=KW
13900	599	X=CODEN(KPN,K,Q,J)
14000		IF(X.NE.4)GO TO 2
14100		BAR=-1
14200		MS=1  
14300		GO TO 100
14400	2	IF(Q(J+2).NE.SN)GO TO 100
14500	CHECK FOR STAFF NUM.
14600		IF(X.EQ.1)GO TO 1
14700	20	IF(X.NE.17)GO TO 12
14800		RSIG=-1
14900		R=Q(J+5)
15000	C KSIG NUM.
15100		A=R+IADD
15200	CHANGED TO A
15300		IF(ABS(A).LT.8)GO TO 123
15400	C AVOIDS IMPOSSIBLE KSIG, DOES ENHARMONIC CHANGE.
15500		IF(A.LT.0)GO TO 223
15600		ITR=9
15700		A=A-12
15800		RT=RT+1
15900		GO TO 123
16000	223	A=A+12
16100		ITR=11
16200		RT=RT-1
16300	123	IF(A.NE.0)GO TO 23
16400		M=Q(J)+3
16500	C THIS WILL DELETE KSIG
16600		ITOT=ITOT-M
16700		KL=ITOT-J
16800		CALL RLOOP(Q(J),Q(J+M),KL)
16900		DO 334 J=K,JITEM
17000	334	KPN(J)=KPN(J+1)-M
17100		JITEM=JITEM-1
17200		K=K-1
17300		GO TO 100
17400	23	Q(J+5)=A
17500		NSIG=0
17600	12	IF(X.EQ.5)GO TO 120
17700		IF(X.NE.3)GO TO 26
17800		IF(Q(J+5).GT.3)GO TO 100
17900	C SKIP NON-CLEFS
18000		IF(CLEF.GE.0)GO TO 100
18100	C FINDS ONLY 1 CLEF PER STAFF
18200	        XCLEF=Q(J+5)
18300		IF(Q(J).LT.3)XCLEF=0
18400		CLEF=0
18500		GO TO 100
18600	26	IF(X.NE.6)GO TO 100
18700	120	IF(RT.NE.8)GO TO 121
18800		IF(XCLEF.EQ.1)RT=-4
18900	C  WHAT ABOUT C CLEFS??
19000	121	Q(J+4)=Q(J+4)+RT
19100		Q(J+5)=Q(J+5)+RT
19200		IF(X.EQ.5)SLUR=Q(J+6)
19300	C  SAVES RIGHT POS. OF SLUR
19400		GO TO 100
19500	C  FOR BEAMS AND SLURS
19600	
19700	1	R=Q(J+4)
19800		XRT=RT
19900		IF(Q(J).LT.6)GO TO 111
20000	C SKIP IF NO STEM INFO
20100		RX=Q(J+8)
20200		IF(RX.GT.999.0)GO TO 111
20300		IF(RX.EQ.999.0)RX=0     
20400		RX=RX+RT
20500		IF(RX.LT.0)RX=0
20600	C RESET STEM LENGTH.  NEVER SHORTER THAN 0 (NORMAL).
20700		Q(J+8)=RX
20800	111	IF(IOCT.LT.0)GO TO 4
20900	C  IOCT=-1 FOR OCT+ OR OCT- 
21000		RX=AMOD(R,100.0)
21100		RZ=AMOD(RX,7.0)
21200	C  THE NOTE NUM
21300		IF(RZ.LT.0)RZ=RZ+7
21400	C  PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
21500		R5=Q(J+5)
21600		A=AMOD(R5,10.0)
21700	C  THE ACCI
21800		RN(MS)=A
21900		RN(MS+1)=RX
22000	C  SAVE FOR REPEATS
22100		MS=MS+2
22200		CHNAT=3
22300		IF(MS.LT.4)GO TO 205
22400		N=MS-3
22500	200	IF(RX.NE.RN(N))GO TO 201
22600		IF(A.EQ.0)GO TO 4
22700	C  NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
22800		GO TO 203
22900	201	N=N-2
23000		IF(N.GE.1)GO TO 200
23100	205	IF(NSIG.LT.0)CHNAT=0
23200	203	ADD=A
23300	C  THE CHANGE IN ACCI
23400		IF(PRX.NE.RX)GO TO 44
23500	C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
23600		IF(A.NE.0)GO TO 44
23700	C NOW SAME NOTE, NO ACCI
23800		IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
23900	C  FOUND CONNECTING TIE
24000	C OR SET MS BACK TO 200 WHEN TIE IS PRESENT.  THIS WILL
24100	CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
24200		IF(BAR.LT.0)MS=1  
24300		IF(A.NE.0)GO TO 203
24400		GO TO 4
24500	44	IF(NSIG.LT.0)GO TO 440
24600	CCC	IF(ITR.GE.17)GO TO 69
24700		IF(A.EQ.0)GO TO 4
24800	C  ONLY CHECKS ON NOTES WITH NO ACCI
24900	   	IF(ITR.GE.18)GO TO 4
25000	
25100	440	IF(XCLEF.NE.1)GO TO 69
25200		RZ=RZ-5
25300		IF(RZ.LT.0)RZ=RZ+7
25400	69	N=A+1
25500		GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53,55
25600		1 ,64),ITR
25700	C  EEb,EE,F-,F#-,G,  Ab,A,Bb,B,DMY,  Db,D,Eb,E,F  BBb
25800	54	IF(RZ.EQ.3)GO TO 101
25900	59	IF(RZ.EQ.6)GO TO 101
26000	52	IF(RZ.EQ.2)GO TO 101
26100	57	IF(RZ.EQ.5)GO TO 101
26200	C  FOR "A".  FINDS C,F AND G.
26300	62	IF(RZ.EQ.1)GO TO 101
26400	55	IF(RZ.EQ.4)GO TO 101
26500	C  "G"   F→Bb, F#→B NAT.
26600		GO TO 4
26700	61	IF(RZ.EQ.5)GO TO 7
26800	56	IF(RZ.EQ.2)GO TO 7
26900	63	IF(RZ.EQ.6)GO TO 7
27000	58	IF(RZ.EQ.3)GO TO 7
27100	53	IF(RZ.NE.0)GO TO 4
27200		
27300	7	GO TO(402,30,405,402,401)N
27400	CIRC7	IF(A.EQ.0)GO TO 402
27500	CIRC	IF(A.EQ.3)GO TO 402
27600	C  CHNG NO ACCI OR NAT TO SHARP
27700	CIRC	IF(A.EQ.4)GO TO 401
27800	C 4=bb   5=##
27900	CIRC	IF(A.EQ.2)GO TO 405
28000	30	ADD=CHNAT
28100	C  MAKE IT NAT. IF NEEDED
28200	3	Q(J+5)=R5-A+ADD
28300	4	PRX=RX
28400	C  REAL NOTE LEVEL
28500		Q(J+4)=R+XRT
28600		BAR=0
28700	100	IF(K.GE.JITEM)GO TO 499
28800		K=K+1
28900		GO TO 599
29000	
29100	
29200	C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
29300	64	IF(XCLEF.EQ.1)XRT=XRT-12
29400		GO TO 58
29500	
29600	101	GO TO(401,404,30,401,404,402)N
29700	CIRC101	IF(A.EQ.0)GO TO 401
29800	CIRC	IF(A.EQ.2)GO TO 30
29900	CIRC	IF(A.EQ.3)GO TO 401
30000	CIRC	IF(A.EQ.5)GO TO 402
30100	C  WON'T HANDLE Gbb→Ab
30200	404	ADD=4
30300		GO TO 3
30400	401	ADD=1
30500		GO TO 3
30600	
30700	402	ADD=2
30800		GO TO 3
30900	405	ADD=5
31000		GO TO 3
31100	499	KW=KW+1
31200		IF(RSIG.LT.0)GO TO 498
31300		IF(IADD.EQ.0)GO TO 498
31400		M=ITOT  
31500	C INSERT NEW KSIG
31600		Q(M)=4
31700		Q(M+1)=17
31800		Q(M+2)=SN
31900		Q(M+3)=9 
32000		Q(M+4)=0 
32100		Q(M+5)=IADD
32200		Q(M+6)=XCLEF
32300		ITOT=ITOT+7
32400		JITEM=JITEM+1
32500		KPN(JITEM+1)=ITOT
32600	498	IF(KW.LT.JPG)GO TO 199
32700		CALL RVRS(JITEM)
32800	C  TO REVERSE STEMS, BEAMS AND SLURS
32900	497	DO 496 K=1,ITEM-1
33000	C THIS REORDERS PTR ARRAY
33100		IF(KPN(K).LT.KPN(K+1))GO TO 496
33200		CALL EXCH(KPN(K),KPN(K+1))
33300		GO TO 497
33400	496	CONTINUE
33500		CALL PUTEXT(NOUT,XOUT)
33600		ITEM=JITEM+2
33700		CALL EXTOUT(JST,128)
33800		CALL EXTOUT(KPN,ITEM)
33900		CALL EXTOUT(Q,ITOT)
34000		CALL FINEXT
34100		TYPE 2201,NOUT,XOUT
34200		NOUT=NOUT+2
34300		NM=NM+2
34400		GO TO 10
34500		END
34600	
34700		FUNCTION ZSIG(XSIG)
34800		TYPE 42
34900	42	FORMAT(' ADD KEY SIG? -- ',$)
35000	43	FORMAT(A1)
35100		ACCEPT 43,XSIG
35200		ZSIG=XSIG
35300		END
35400	
35500		FUNCTION AVERG(J,JJ,LEND)
35600		COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
35700	 	1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
35800		1 /IPG/IPG,JPG,BRA(8),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(8)
35900	 
36000	C FIRST GET RIGHT END POSITION OF BEAM
36100		END=Q(JJ+6)+.2
36200		LL=Q(JJ+7)/10.
36300	C STEM DIRECTION OF BEAM
36400		BOT=999.
36500		TOP=-BOT
36600		AVERG=0
36700		K=J
36800	1	R=CODEN(KPN,K,Q,KK)
36900	C FIND CODE NUM.
37000		IF(Q(KK+3).GT.END)GO TO 3
37100	C JUMP OUT IF PAST RIGHT SIDE OF BEAM
37200		IF(R.NE.1)GO TO 2
37300	C JUMP IF NOT A NOTE
37400		IF(Q(KK+2).NE.SN)GO TO 2
37500	C JUMP IF NOT ON RIGHT STAFF
37600		L=Q(KK+5)/10.
37700		IF(L.NE.LL)GO TO 4
37800	C JUMP OUT IF ANY NOTE HAS WRONG STEM DIRECTION.
37900		A=AMOD(Q(KK+4),100.0)
38000	C GET HEIGHT OF NOTE
38100		IF(A.LT.BOT)BOT=A
38200		IF(A.GT.TOP)TOP=A
38300	2	K=K+1
38400		IF(K.GT.LEND)GO TO 4
38500	C IF AT END OF DATA, JUMP OUT (SHOULD NOT GET HERE!)
38600		GO TO 1
38700	3	A=(TOP+BOT)/2.
38800	C AVERG=0=STEMS SHOULD GO UP, 1=DOWN
38900		IF(A.GE.7)AVERG=1.
39000		RETURN
39100	4	IF(LL.EQ.2)AVERG=1.
39200	C USE STEM DIR. OF BEAM IF NOTES HAVE VARYING STEMS.
39300		END